home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2005 October / PCWOCT05.iso / Software / FromTheMag / Ant Movie Catalog 3.5.0.2 / amc_install.exe / {app} / Scripts / StringUtils7552.pas < prev    next >
Pascal/Delphi Source File  |  2005-02-11  |  18KB  |  454 lines
  1. unit StringUtils7552;
  2.  
  3. {
  4.   See comments in StringUtils1.pas for general infos
  5.   
  6.   This file was created by scorpion7552
  7.   Of course, you can use these functions in your scripts :
  8.   simply add "StringUtils7552" in the uses clause of your script.
  9.     note that I also use StringUtils1 here, so you get the 2 for the same price...
  10.     
  11.     BUT remember that I have created this file for my own needs and that these
  12.     functions/procedures may change one day or another without notification,
  13.     ... or even disappear
  14. }
  15. uses
  16.     StringUtils1;
  17.  
  18. const
  19.     crlf = #13#10;                        // carriage return/line feed
  20. // I use the 2 next characters to separate fields in a string
  21. // (for parsing without confusion with real characters)
  22.     sepchar1 = #02;                       // internal separator 1
  23.     sepchar2 = #03;                       // internal separator 2
  24. // special characters
  25.     spec1 = '" ! ? , : ; / ( )';
  26.     spec2 = ''' . -';
  27.     
  28. var
  29.     FormatUTF8: Integer;                  // flag: see FormatText
  30.     memoAdr, memoTxt: TStringList;        // memo lists: see SelectMovie
  31.  
  32. // general purpose
  33.  
  34. //------------------------------------------------------------------------------
  35. // sort a StringList (ascending)
  36. //------------------------------------------------------------------------------
  37. procedure SortList(stringl: TStringList);
  38. var
  39.     i1, i2, imin: Integer;
  40.     min, min2: String;
  41.  
  42. begin
  43.     for i1 := 0 to stringl.count -2 do
  44.     begin
  45.         min := stringl.GetString(i1);         // current = min
  46.         imin := i1;
  47. // search the smallest entry in next 
  48.         for i2 := i1 +1 to stringl.count-1 do
  49.         begin
  50.             min2 := stringl.GetString(i2);
  51.             if min2 < min then 
  52.             begin                              // current (i2) = new min
  53.                 min := min2;                     // memorize it and continue
  54.                 imin := i2;
  55.             end;
  56.         end;    {for i2}
  57.         if imin <> i1 then                   // swap current (i1) and new min (imin)
  58.             stringl.Exchange(i1, imin);    
  59.     end;      {for i1}
  60. end;
  61.  
  62. //------------------------------------------------------------------------------
  63. // returns the number of words of a string
  64. //------------------------------------------------------------------------------
  65. function Words(str: string) :integer;
  66. var
  67.     vcountwords: TStringList;
  68.     
  69. begin
  70.     vcountwords := TStringList.Create;
  71.     vcountwords.Text := StringReplace(str, ' ', crlf);              // parse words
  72.     result := vcountwords.Count;
  73.     vcountwords.Free;
  74. end;
  75.  
  76. //------------------------------------------------------------------------------
  77. // returns percentage (integer) of words of string1 found in string2 
  78. // of course, both strings must be formatted using the same routine
  79. // (like CleanString for example)
  80. // note that 100 means exact match
  81. //------------------------------------------------------------------------------
  82. function CompareWords(str1, str2: string) :integer;
  83. var
  84.     wcount, i: integer;
  85.     strl1, strl2: TStringList;
  86.     w: string;
  87.  
  88. begin
  89.     wcount := 0;                                    // counter 
  90.     strl1 := TStringList.Create;
  91.     strl1.Text := StringReplace(str1, ' ', crlf);   // parse words
  92.     strl2 := TStringList.Create;
  93. // strange: we can use IndexOfName and GetName but not GetValue and IndexOf ???
  94.     strl2.Text := StringReplace(str2+'=', ' ', '='+crlf);  // for IndexOfName
  95.     for i := 0 to strl1.Count -1 do                 // look for words of string1
  96.     begin
  97.         w := strl1.GetString(i);                      // current word of string1
  98.         if w = '' then continue;
  99.         if strl2.IndexOfName(w) <> -1 then            // match
  100.             wcount := wcount +1;
  101.     end;  {for i}                      
  102.     if strl1.Count > 0 then                     // don't like 'divide by zero' !!!
  103.     begin
  104.         wcount := (wcount * 100) div strl1.Count;                      // percentage
  105. // if all words of string1 have been found in string2 (in any order)
  106. // but string2 is longer than string1, we can't count that as exact match !
  107.         if (wcount = 100) and (strl2.Count > strl1.Count) then
  108.             wcount := wcount - (strl2.Count - strl1.Count);
  109.     end;
  110.     result := wcount; 
  111. end;
  112.  
  113. //------------------------------------------------------------------------------
  114. // returns the movie name stored in amc
  115. //------------------------------------------------------------------------------
  116. Function GetMovieName:string;
  117. begin
  118.     result := GetField(fieldTranslatedTitle);                  // first translated
  119.     if result = '' then    result := GetField(fieldOriginalTitle);     // or original   
  120. end;
  121.  
  122. //------------------------------------------------------------------------------
  123. // returns a string translated to lowercase without accents 
  124. //------------------------------------------------------------------------------
  125. function AnsiLowerCaseNoAccents(str1: string) :string;
  126. begin
  127.     str1 := AnsiLowerCase(str1); 
  128.     str1 := StringReplace(str1, 'α', 'a'); 
  129.     str1 := StringReplace(str1, 'ß', 'a');         
  130.     str1 := StringReplace(str1, 'Γ', 'a');
  131.     str1 := StringReplace(str1, 'π', 'a');    
  132.     str1 := StringReplace(str1, 'Σ', 'a'); 
  133.     str1 := StringReplace(str1, 'π', 'a');
  134.     str1 := StringReplace(str1, 'Θ', 'e');   
  135.     str1 := StringReplace(str1, 'Φ', 'e');
  136.     str1 := StringReplace(str1, 'δ', 'e');
  137.     str1 := StringReplace(str1, 'Ω', 'e'); 
  138.     str1 := StringReplace(str1, '∩', 'i');
  139.     str1 := StringReplace(str1, 'ε', 'i');
  140.     str1 := StringReplace(str1, '∞', 'i');
  141.     str1 := StringReplace(str1, 'φ', 'i');
  142.     str1 := StringReplace(str1, '⌠', 'o');
  143.     str1 := StringReplace(str1, '÷', 'o');
  144.     str1 := StringReplace(str1, '⌡', 'o');
  145.     str1 := StringReplace(str1, '≥', 'o');
  146.     str1 := StringReplace(str1, '≤', 'o');
  147.     str1 := StringReplace(str1, '∙', 'u');
  148.     str1 := StringReplace(str1, 'ⁿ', 'u');  
  149.     str1 := StringReplace(str1, '√', 'u');
  150.     str1 := StringReplace(str1, '·', 'u');
  151.     str1 := StringReplace(str1, 'τ', 'c');
  152.     str1 := StringReplace(str1, '±', 'n');
  153.     result := str1;
  154. end;
  155.  
  156. //------------------------------------------------------------------------------
  157. // returns a string with 1st article removed (first word only)
  158. //------------------------------------------------------------------------------
  159. function RemoveArticles(str1: string) :string;
  160. var
  161.   Articles: array of string;
  162.   i: integer;
  163.   str2: String;
  164.  
  165. begin
  166.     SetArrayLength(Articles,32);      
  167.   Articles[0]:='le ';        
  168.   Articles[1]:='la ';
  169.   Articles[2]:='l''';        
  170.   Articles[3]:='l ';
  171.   Articles[4]:='les ';
  172.   Articles[5]:='des ';
  173.   Articles[6]:='un ';
  174.   Articles[7]:='une ';
  175.   Articles[8]:='the ';
  176.   Articles[9]:='a ';
  177.   Articles[10]:='an ';
  178.   Articles[11]:='der ';
  179.   Articles[12]:='das ';
  180.   Articles[13]:='die ';
  181.   Articles[14]:='dem ';
  182.   Articles[15]:='den ';
  183.   Articles[16]:='ein ';
  184.   Articles[17]:='eine ';
  185.   Articles[18]:='einen ';
  186.   Articles[19]:='einer ';
  187.   Articles[20]:='eines ';
  188.   Articles[21]:='einem ';
  189.   Articles[22]:='uno ';
  190.   Articles[23]:='una ';
  191.   Articles[24]:='el ';
  192.   Articles[25]:='los ';
  193.   Articles[26]:='las ';
  194.   Articles[27]:='unos ';
  195.   Articles[28]:='unas ';  
  196.   Articles[29]:='il ';
  197.   Articles[30]:='lo ';
  198.   Articles[31]:='i ';
  199.   str2 := AnsiLowerCase(str1);
  200.   for i := 0 to GetArrayLength(articles)-1 do
  201.   begin
  202.     if Pos(Articles[i], str2) = 1 then
  203.     begin
  204.             str1 := Copy(str1, Length(Articles[i])+1, length(str1));
  205.       Break;
  206.     end;
  207.   end;        {for i}
  208.     result := Trim(str1); 
  209. end;
  210.  
  211. //------------------------------------------------------------------------------
  212. // returns a string with special characters translated (&   etc...)
  213. //------------------------------------------------------------------------------
  214. function TranslateSpecial(str1: string) :string;
  215. begin
  216. // sometimes, pages are coded with &nbsp; (yes, I have seen that...)
  217. // Don't know why they don't code directly   (mistake ?)
  218. // so first change '&' with '&', then HTMLDecode will be happy 
  219.     str1 := StringReplace(str1, '&', '&');
  220. // translate special characters  
  221.     HTMLDecode(str1);
  222.     result := Trim(str1);
  223. end;
  224.  
  225. //------------------------------------------------------------------------------
  226. // returns a string with blanks and crlf compacted (and more...)
  227. // if flag = 'spec1' : remove special characters (spec1)
  228. // and/or flag = 'spec2' : replace special characters (spec2) with blank
  229. //------------------------------------------------------------------------------
  230. function CompactString(str1, flag: String) :string;
  231. var
  232.     s1, m, str2 : string;
  233.     i: integer;
  234.  
  235. begin
  236.     if flag <> '' then                                 // replace & ... stuffs          
  237.         str1 := TranslateSpecial(str1); 
  238.     m := '';
  239.     str2 := '';
  240.     i := 0;
  241.     while (i < Length(str1)) do
  242.     begin
  243.         i := i + 1;
  244.         s1 := Copy(str1, i, 1);                        // current character of str1
  245.         if s1 = #09 then s1 := ' ';                    // replace Tab ('09'x) with blank
  246.         if (s1 <> ' ') and (flag <> '') then           // treat special characters
  247.         begin
  248.             if Pos('spec1', flag) > 0 then                 // remove spec1
  249.                 if Pos(s1, spec1) > 0 then continue;
  250.             if Pos('spec2', flag) > 0 then                 // replace spec2
  251.                 if Pos(s1, spec2) > 0 then s1 := ' ';
  252.         end;
  253.         if (s1 = ' ') and (s1 = m) then continue;      // ignore multiple blanks
  254.         if s1 = #13 then                               // cr: maybe crlf
  255.         begin
  256.             s1 := Copy(str1, i, 2);
  257.             i := i +1;
  258.             if (s1 = crlf) and (s1 = m) then continue;   // ignore multiple crlf
  259.         end;
  260.         m := s1;                                       // memo current character(s)
  261.         str2 := str2+s1;                               // and store
  262.     end;         {while i < length(str1)}
  263.     result := Trim(str2);
  264. end;
  265.  
  266. //------------------------------------------------------------------------------
  267. // returns a string formatted according to the following convention
  268. // final_text := TranslateText(initial_text, format_type);
  269. // format_type (integer)
  270. // 0 : no change
  271. // 1 : change all characters to lowercase
  272. // 2 : change all characters to uppercase
  273. // 3 : first character to uppercase, the others to lowercase
  274. // 4 : all first characters of words to uppercase, the others to lowercase
  275. //------------------------------------------------------------------------------
  276. function TranslateText(str1: string; f: integer) :string;
  277. begin
  278.     case f of
  279.     1: result := AnsiLowerCase(str1);
  280.     2: result := AnsiUpperCase(str1);
  281.     3: result := AnsiUpFirstLetter(AnsiLowerCase(str1)); 
  282.     4: result := AnsiMixedCase(AnsiLowerCase(str1), ' '); 
  283.     else result := str1;
  284.     end; 
  285. end;
  286.  
  287. //------------------------------------------------------------------------------
  288. // dump a string to disk 
  289. // DumpPage(path_of_the_file,string)
  290. // path_of_the_file = complete path (ie: 'c:\temp\myfile.txt')
  291. // note: the directory (if any) must be created before
  292. //------------------------------------------------------------------------------
  293. procedure DumpPage(filePath, WholeText: string);
  294. var
  295.     page: TStringList;
  296.  
  297. begin
  298.     page := TStringList.Create;
  299.     page.Text := WholeText;
  300.     page.SaveToFile(filePath);
  301.     page.Free;
  302. end;
  303.     
  304. //------------------------------------------------------------------------------
  305. // create and display a list (of movies or what you want) 
  306. // and returns the selected address or ''
  307. // addr := SelectMovie('title_for_display');
  308. // note: global TStringList's must be initialized
  309. //       memoAdr.   = url of page (or what you want)
  310. //       memo.Text. = text to display (you can separate tokens with sepchar1)
  311. //------------------------------------------------------------------------------
  312. function SelectMovie(title: string) :string;
  313. var
  314.     Address: String;
  315.     i: integer;
  316.  
  317. begin
  318.     PickTreeClear;                                   // clear list
  319.     PickTreeAdd(title, '');
  320.     for i:= 0 to memoTxt.Count -1 do                 // create the list
  321.     PickTreeAdd(StringReplace(memoTxt.GetString(i), sepchar1, ''), memoAdr.GetString(i));  
  322.     result := '';
  323.     if PickTreeExec(Address) then result := Address;
  324. end;
  325.     
  326. // more or less specific
  327.         
  328. //------------------------------------------------------------------------------
  329. // returns the url contained in a string without edition
  330. // addr := GetUrl(string_containing_url, start_from_or_'',base_url_or_'');
  331. //------------------------------------------------------------------------------
  332. function GetUrl(WholeText, StartFrom, urlb: string) :string;
  333. var
  334.     i: Integer;
  335.     delim: char;
  336.  
  337. begin
  338.     result := '';
  339.     if StartFrom <> '' then                        // if StartFrom = '', start from begining of string
  340.     begin
  341.         i := Pos(StartFrom, WholeText); 
  342.         if i = 0 then exit;                          // StartFrom not found
  343.         Delete(WholeText,1, i -1);                   // delete characters before StartFrom
  344.     end; 
  345.     i := Pos('HREF=', AnsiUpperCase(WholeText));       // start of url: href= 
  346.     if i = 0 then exit;                            // no href= found
  347.     Delete(WholeText,1, i +4);                     // skip href=
  348.     WholeText := TextBefore(WholeText, '>', '');   // stop at the end of tag
  349.     delim := StrGet(WholeText, 1);                 // delimiter = " or ' or nothing special
  350.     if (delim = '''') or (delim = '"') then        // skip ' or " 
  351.         Delete(WholeText, 1, 1)                      
  352.     else
  353.         delim := ' ';                                 // no delimiter: stop at first blank if any
  354.     i := Pos(delim, WholeText);   
  355.     if i > 0 then    Delete(WholeText,i, Length(WholeText));
  356.     WholeText := StringReplace(WholeText, '&', '&');
  357.     WholeText := StringReplace(WholeText, '../', '');    // cf relative address
  358.     WholeText := StringReplace(WholeText, './', '');     
  359.     WholeText := urlb + WholeText;                       // add base url if any 
  360.     result := Trim(WholeText);
  361. end;
  362.         
  363. //------------------------------------------------------------------------------
  364. // returns a string formatted for display - special stuffs
  365. // see comments in FormatText2
  366. //------------------------------------------------------------------------------
  367. function FormatText(initialText: string) :string;
  368. begin
  369. // paragraphs (HTML tags) = crlf (that's my choice, isn't it?)
  370.     initialText := StringReplace(initialText, '</p>', crlf); 
  371.     initialText := StringReplace(initialText, '<p>', crlf);
  372. // now "standard" formatting
  373.     result := FormatText2(initialText);
  374. end;
  375.  
  376. //------------------------------------------------------------------------------
  377. // returns a string formatted for display - this text may contain html tags 
  378. // and special characters( & < > "  )
  379. // formatted_text := FormatText(initial_text);
  380. // if your text is coded using UTF-8 then you must code in the caller script:
  381. //    FormatUTF8 := 1;
  382. // if all your texts are in pure ASCII, then you have nothing to do ...
  383. // or if you have a mix, then you must set FormatUTF8 accordingly (0 or 1)
  384. //------------------------------------------------------------------------------
  385. function FormatText2(initialText: string) :string;
  386. var
  387.     s: char;
  388.     i: integer;
  389.  
  390. begin
  391.     result := '';
  392.     if initialText = '' then exit;                           // nothing to convert
  393.     if FormatUTF8 = 1 then
  394.     begin
  395.         initialText := UTF8Decode(initialText);                // UTF-8 to ASCII
  396. // some strange characters not translated....
  397.         initialText := StringReplace(initialText, #160, ' ');  // 'A0'x 
  398.     end;
  399. // suppress HTML tags and translate special characters (& ...)
  400.     HTMLRemoveTags(initialText);
  401.     initialText := TranslateSpecial(initialText);
  402. // suppress formatting characters at the begining and at the end of string 
  403. // (except sepchar1 and sepchar2)
  404.     while (initialText <> '') do
  405.     begin
  406.     s := StrGet(initialText, 1);                   // 1st character of initialText
  407.      if (s = #0) or (s > #32) or (s = sepchar1) or (s = sepchar2) then break;  // ended
  408.     Delete(initialText, 1, 1);                       // out
  409.     end;
  410. //
  411.     while (initialText <> '') do
  412.     begin
  413.     i := Length(initialText);
  414.     s := StrGet(initialText, i);                  // last character of initialText
  415.     if (s = #0) or (s > #32) or (s = sepchar1) or (s = sepchar2) then break;  // ended 
  416.     Delete(initialText, i, 1);                       // out
  417.     end;
  418. // and compact string (leaving spec1 and spec2 asis)
  419.     result := CompactString(initialText, '');
  420. end;
  421.  
  422. //------------------------------------------------------------------------------
  423. // returns the movie name formatted (for input to search engines)
  424. // note that this is not very universal, but maybe can fit your needs... 
  425. //------------------------------------------------------------------------------
  426. function FormatMovieName(str: string) :string;
  427. var
  428.     i: integer;
  429.     
  430. begin
  431. // sometimes, movie names are coded as 'usual title/alternate title'
  432. // keep only the usual name
  433.     i := Pos('/', str);                  
  434.     if i > 0 then str := Left(str, i-1);
  435.     str := AnsiLowerCaseNoAccents(str);              // lower case without accents
  436. // some search engines limit the number of key words used
  437. // so it's better to remove the 1st article (if more than 3 words)
  438.     if Words(str) > 3 then 
  439.         str := RemoveArticles(str);
  440. // compact string and remove spec1 (don't treat spec2 here)
  441.     result := CompactString(str, 'spec1'); 
  442. end;
  443.  
  444. //------------------------------------------------------------------------------
  445. // returns a string with all special characters suppressed (for comparisons)
  446. //------------------------------------------------------------------------------
  447. function CleanString(str1: string) :string;
  448. begin;
  449.     str1 := AnsiLowerCaseNoAccents(str1);          // lowercase without accents
  450.     result := CompactString(str1, 'spec1 spec2');  // compact string (treat spec1 and spec2)
  451. end;
  452.  
  453. end.
  454.